procedure choice
parameter line,column,message,option,choice
  char = ' '
do while .not. char $ option
   char = choice
   set color to w/B+
   @ line,column say message get char picture '@!'
   read
   set color to w
enddo
choice = char
return


proc mn_formddd
set inte on
set colo to r+/b,w+/n
@ 23,09 clea to 23,69
@ 23,14 prompt 'Get'
@ 23,19 prompt 'Beg'
@ 23,24 prompt 'End'
@ 23,29 prompt 'Next'
@ 23,35 prompt 'Prev'
@ 23,41 prompt 'Mod'
@ 23,46 prompt 'Add'
@ 23,51 prompt 'Del'
@ 23,55 prompt 'List'
@ 23,61 prompt 'Quit'
set colo to w/r+
menu to option
set colo to
set inte off
return

******************* MULTY USER PROCEDUR ******************

function net_use
parameters file,ex_use,area,wait
private forever

forever = (wait = 0)
do while (forever .or. wait > 0)
   if ex_use
      sele &area
      use &file exclusive
   else
      sele &area
      use &file
   endif

   if .not. neterr()
      return (.t.)
   endif
   inkey(1)
   wait = wait - 1
enddo
return (.f.)


function fil_lock
parameters wait
private forever
if flock()
   return (.t.)
endif
forever = (wait = 0)
do while (forever .or. wait > 0)
   inkey(.5)
   wait = wait - .5
   if flock()
      return (.t.)
   endif
enddo
return (.f.)



function rec_lock
parameters wait
private forever
if rlock()
   return (.t.)
endif
forever = (wait = 0)
do while (forever .or. wait > 0)
   if rlock()
      return (.t.)
   endif
   inkey(.5)
    wait = wait - .5
enddo
return (.f.)


function add_rec
parameters wait
private forever

append blank
if .not. neterr()
   return (.t.)
endif
forever = (wait = 0)
do while (forever .or. wait > 0)
   append blank
   if .not. neterr()
      return (.t.)
   endif
   inkey(.5)
   wait = wait - .5
enddo
return (.f.)


PROC START

set talk off
set scor off
set escape on
set bell off
set intensity on
set print off
set device to screen
set safety off
set delete on
set date british
set wrap on
DR='N:'
F1='AEACORP'
set exclu off
USE &DR&F1
GO TOP
AEANAME=COMP_NAME
AEAADDR=COMP_ADDR
AEACITY=COMP_CITY
AEACOUN=COMP_COUN
AEACURR=COMP_CURR
AEAHEAL=COMP_HEAL
AEADECI=COMP_DECI
AEABCUR=COMP_CHCR
AEAPRIN=COMP_PRIN
AEADIAG=COMP_DIAG
vat    =comp_vat
cVISIT_TAX = VISIT_TAX
cCCARD_TAX = CCARD_TAX
cComp_SRV = COMP_SRV
USE

CLEA
RETURN



proc set_dev

ok=.f.
do while .not. ok
   outp_dev = 'P'
   do choice with 14,33,'Print/Quit','PQ',outp_dev
   ok = .T.
   do case
      case outp_dev = 'P'
         pr_ok = 'Y'
         do choice with 15,26,'Printer Ready Y/N','YN',pr_ok
         if pr_ok = 'N'
            ok = .F.
         else
            @ 16,34 say 'Printing...'
            set console off
            RETURN
         endif
      case outp_dev = 'Q'
         KLR='Y'
         return
   endcase
enddo
return


proc mn_form

set inte on
set colo to w+/R,w+/n
@ 23,01 clea to 23,78
@ 23, 5 prompt 'Get'
@ 23,12 prompt 'Beg'
@ 23,19 prompt 'End'
@ 23,26 prompt 'Next'
@ 23,34 prompt 'Prev'
@ 23,42 prompt 'Mod'
@ 23,49 prompt 'Add'
@ 23,56 prompt 'Del'
@ 23,63 prompt 'List'
@ 23,71 prompt 'Quit'
set colo to w/r+
menu to option
set colo to
set inte off
return

PROC FIXTIM

BLHOUR=IIF(BHOUR<10,'0'+ALLTRIM(STR(BHOUR,1,0)),ALLTRIM(STR(BHOUR,2,0)))
BLMIN=IIF(BMIN<10,'0'+ALLTRIM(STR(BMIN,1,0)),ALLTRIM(STR(BMIN,2,0)))
BTIME=BLHOUR+'h'+BLMIN
BTIM=BHOUR*3600+BMIN*60
ETIM=BTIM+DURAT
EHOUR=INT(ETIM/3600)
EMIN=INT((ETIM-(EHOUR*3600))/60)
ELHOUR=IIF(EHOUR<10,'0'+ALLTRIM(STR(EHOUR,1,0)),ALLTRIM(STR(EHOUR,2,0)))
ELMIN=IIF(EMIN<10,'0'+ALLTRIM(STR(EMIN,1,0)),ALLTRIM(STR(EMIN,2,0)))
ETIME=ELHOUR+'h'+ELMIN
RETURN

proc givecod

PATI='PT'+AWNAME
REST FROM N:PATI ADDITIVE
AWNM=left(&PATI,1)
NOWO=LTRIM(STR(INT(VAL(SUBSTR(&PATI,2,5))+1)))
blank=5-len(nowo)
do case
   case blank=4
      kodepat=awnm+'0000'+nowo
   case blank=3
      kodepat=awnm+'000'+nowo
   case blank=2
      kodepat=awnm+'00'+nowo
   case blank=1
      kodepat=awnm+'0'+nowo
   case blank=0
      kodepat=awnm+nowo
endcase
&PATI=KODEPAT
SAVE ALL LIKE PT* TO N:PATI
return



func NTOS2
para NILAI,SAT1,SAT2
priv STRING1,STRING2,W_LENGTH,S_NILAI1,S_NILAI2,S_NILAI3,S_NILAI4,S_NILAI5,WSPELL,I,J

STRING1='ONE  TWO  THREEFOUR FIVE SIX  SEVENEIGHTNINE '
STRING2='TWENTY THIRTY FORTY  FIFTY  SIXTY  SEVENTYEIGHTY NINETY '
STRING3='BILLION MILLION THOUSANDHUNDRED '
STRING4='TEN      ELEVEN   TWELVE   THIRTEEN FOURTEEN FIFTEEN  SIXTEEN  SEVENTEENEIGHTEEN NINETEEN '
WSPELL=''
S_NILAI1=subs(str(NILAI,15,2),1,3)
S_NILAI2=subs(str(NILAI,15,2),4,3)
S_NILAI3=subs(str(NILAI,15,2),7,3)
S_NILAI4=subs(str(NILAI,15,2),10,3)
S_NILAI5='0'+subs(str(NILAI,15,2),14,2)
for J=1 to 5
   I=alltrim(str(J))
   if val(S_NILAI&I)#0
      do SPELL1
      if J<4
         WSPELL=WSPELL+rtrim(subs(STRING3,(J-1)*8+1,8))
         WSPELL=WSPELL+' '
      endi
   endi
   if J=4
      if int(NILAI)#0
         if int(NILAI)=1
            WSPELL=WSPELL+alltrim(SAT1)
         else
            if .not. empty(SAT1)
               WSPELL=WSPELL+alltrim(SAT1)+'S'
            endi
         endi
      endi
      if val(S_NILAI5)#0
         if int(NILAI)#0
            WSPELL=WSPELL+' AND '
         endi
      endi
   endi
next
if val(S_NILAI5)#0
   if val(S_NILAI5)=1
      WSPELL=WSPELL+alltrim(SAT2)
   else
      if .not. empty(SAT2)
         WSPELL=WSPELL+alltrim(SAT2)+'S'
      endi
   endi
endi
retu(WSPELL)
*** end function NTOS2

procedure SPELL1

if val(subs(S_NILAI&I,1,1))#0
   WSPELL=WSPELL+rtrim(subs(STRING1,(val(subs(S_NILAI&I,1,1))-1)*5+1,5))+' HUNDRED'
      WSPELL=WSPELL+' AND '
endi
if val(subs(S_NILAI&I,2,2))>19 .and. val(subs(S_NILAI&I,2,2))<100
   if val(subs(S_NILAI&I,2,1))#0
      WSPELL=WSPELL+rtrim(subs(STRING2,(val(subs(S_NILAI&I,2,1))-2)*7+1,7))+' '
   endi
   if val(subs(S_NILAI&I,3,1))#0
      WSPELL=WSPELL+rtrim(subs(STRING1,(val(subs(S_NILAI&I,3,1))-1)*5+1,5))+' '
   endi
endi
if val(subs(S_NILAI&I,2,2))>=10 .and. val(subs(S_NILAI&I,2,2))<20
   WSPELL=WSPELL+rtrim(subs(STRING4,(val(subs(S_NILAI&I,2,2))-10)*9+1,9))+' '
endi
if val(subs(S_NILAI&I,2,2))>0 .and. val(subs(S_NILAI&I,2,2))<10
   WSPELL=WSPELL+rtrim(subs(STRING1,(val(subs(S_NILAI&I,2,2))-1)*5+1,5))+' '
endi
retu

proc S_PARSE
para L_STRING,LINE_NUM,S_LENGTH,W_ARRAY

XSTART=1
for I=1 to LINE_NUM
   XEND=XSTART+S_LENGTH-1
   if XEND>=len(L_STRING)
      W_ARRAY[I]=subs(L_STRING,XSTART,len(L_STRING)+1-XSTART)
      retu
   endi
   do whil subs(L_STRING,XEND,1)#' '
      XEND=XEND-1
   endd
   W_ARRAY[I]=subs(L_STRING,XSTART,XEND+1-XSTART)
   XSTART=XEND+1
   if XSTART>len(L_STRING)
      retu
   endi
next
retu


procedure tanya
parameter line,column,option,choice
  char = ' '
  do while .not. char $ option
    char = choice
    @ line,column get char picture '@!'
    read
  enddo
  choice = char
return

PROCEDURE SCREEN
set colo to w+/rb,gr+/r
@ 9,0 clea to 21,24
@ 9,0 to 21,24 double
@ 10,2 say "General Practitioners"
@ 11,2 say "Specialists          "
@ 12,2 say "Dental               "
@ 13,2 say "SurgerY              "
@ 14,2 say "Laboratory test      "
@ 15,2 say "X-Ray and U.S.G.     "
@ 16,2 say "Clinic fees          "
@ 17,2 say "Physical examination "
@ 18,2 say "Emergency room       "
@ 19,2 say "Health and Fitness   "
@ 20,2 say "Medications          "
set colo to gr+/Rb
@ 10,2 say "G"
@ 11,2 say "S"
@ 12,2 say "D"
@ 13,8 say "Y"
@ 14,2 say "L"
@ 15,2 say "X"
@ 16,2 say "C"
@ 17,2 say "P"
@ 18,2 say "E"
@ 19,2 say "H"
@ 20,2 say "M"
procedure get_optn
parameters message, choices, choice
set color to w/r+
@ 23,00
char = ' '
do while .not. char $ choices
   char = choice
   @ 23,(38-len(message)/2)  say message get char picture '!'
   read
enddo (while .not. char $ choices)
choice = char
set color to w
return

PROC SAYG
PARA BRS,KOL,AAA,PIC1,PIC2
IF AEADECI
   @ BRS,KOL SAY AAA PICT PIC1
ELSE
   @ BRS,KOL SAY AAA PICT PIC2
ENDIF
RETURN

PROC GETS
PARA BRS,KOL,AAA,PIC1,PIC2
IF ADEPO
   @ BRS,KOL GET AAA PICT PIC1
ELSE
   @ BRS,KOL GET AAA PICT PIC2
ENDIF
READ
RETURN
